{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  OchreLang.Parser
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Parser.
--
--------------------------------------------------------------------------------

module OchreLang.Parser 
  ( 

    parseMainModule
  , parseLibraryModule
  , parseBuiltins

  ) where
  
import OchreLang.Builtin
import qualified OchreLang.OrchSpec as OS
import OchreLang.SyntaxBase
import OchreLang.TopSyntax
import OchreLang.Types

import Text.Parsec                              -- package: parsec
import Text.Parsec.Error 
import Text.Parsec.Language
import Text.Parsec.Pos ( initialPos )
import Text.Parsec.String
import qualified Text.Parsec.Token as P

import Control.Applicative hiding ( (<|>), many )
import Control.Monad.Identity
import System.Directory


type OchreParser a      = ParsecT String () Identity a
type OchreLexer         = P.GenTokenParser String () Identity


parseMainModule :: FilePath -> IO (Either ParseError (OS.OrchSpec, Module))
parseMainModule = safeParseFromFile mainModule

parseLibraryModule :: FilePath -> IO (Either ParseError Module)
parseLibraryModule = safeParseFromFile libraryModule


parseBuiltins :: FilePath -> IO (Either ParseError [Builtin])
parseBuiltins = safeParseFromFile (builtins <?> "builtins")


safeParseFromFile :: Parser a -> FilePath -> IO (Either ParseError a)
safeParseFromFile p file_path = do 
    b <- doesFileExist file_path
    if b then parseFromFile p file_path 
         else return (Left missing_error)
  where
    missing_error = newErrorMessage (SysUnExpect missing_text) 
                                    (initialPos file_path)
    missing_text  = "ERROR: cannot find file - " ++ file_path

--------------------------------------------------------------------------------
-- Extra combinators

-- A Left factoring combinator - this formulation avoids some parens
-- but its use is admittedly cryptic.
--
(<??>) :: OchreParser a -> OchreParser (a -> a) -> OchreParser a
p <??> q = do { a <- p
              ; mf <- optionMaybe q
              ; return $ case mf of { Nothing -> a ; Just f -> f a }
              }


prefixSepBy :: OchreParser a -> OchreParser b -> OchreParser sep 
            -> OchreParser (a,[b])
prefixSepBy pa pb psep = (,) <$> (pa <* psep) <*> sepBy pb psep



--------------------------------------------------------------------------------
-- Builtins Parser

builtins :: OchreParser [Builtin]
builtins = whiteSpace *> builtins1 <* eof

builtins1 :: OchreParser [Builtin]
builtins1 = reserved "builtins" *> braces (semiSep builtin)

builtin :: OchreParser Builtin
builtin = Builtin <$> (ident <* reservedOp ":") 
                  <*> (stringLiteral <* reservedOp "::")
                  <*> funType
       <?> "builtin"

--------------------------------------------------------------------------------
-- Type parser

funType :: OchreParser Type
funType = TyFun <$> pArgs <*> (reservedOp "->" *> ansType) 
  where
    pArgs = braces $ commaSep (listType <|> scalarType)

scalarType :: OchreParser Type
scalarType = choice [ tyAny, tyInt, tyFloat, tyString, tySig ]

ansType :: OchreParser Type
ansType = monType <|> simpleAnsType

simpleAnsType :: OchreParser Type
simpleAnsType = tyNull <|> tupleType <|> scalarType
            

monType :: OchreParser Type
monType = TyCsMon <$> (reserved "Cs" *> simpleAnsType)

tupleType       :: OchreParser Type
tupleType       = TyTuple <$> parens (commaSep1 scalarType)

listType        :: OchreParser Type
listType        = TyList <$> brackets (commaSep1 scalarType)
               <?> "lsitType"

-- | Use try because we don\'t want to common prefix the lparen 
-- with tuple.
--
tyNull          :: OchreParser Type
tyNull          = TyNull <$ ( try (symbol "(" *> symbol ")"))

tyAny           :: OchreParser Type
tyAny           = TyAny <$ reserved "Any"

tyInt           :: OchreParser Type
tyInt           = TyInt <$ reserved "Int"

tyFloat         :: OchreParser Type
tyFloat         = TyInt <$ reserved "Float"

tyString        :: OchreParser Type
tyString        = TyString <$ reserved "String"

tySig           :: OchreParser Type
tySig           =  (TyASig <$ reserved "ASig")
               <|> (TyKSig <$ reserved "KSig")
               <|> (TyISig <$ reserved "ISig")
               <|> (TyKA <$ reserved "KA")

--------------------------------------------------------------------------------
-- Module parser


mainModule :: OchreParser (OS.OrchSpec, Module)
mainModule = 
    (\(name,imps) ospec (insts,traits) -> 
        let modul = Module { module_name        = name
                           , module_imports     = imps
                           , module_instrs      = insts
                           , module_traits      = traits
                           }
        in (ospec,modul) )
      <$> moduleHead <*> orchSpec <*> moduleTail


libraryModule :: OchreParser Module
libraryModule = 
    (\(name,imps) (insts,traits) -> Module { module_name        = name
                                           , module_imports     = imps
                                           , module_instrs      = insts
                                           , module_traits      = traits
                                           } )
      <$> moduleHead <*> moduleTail


-- | Name and Import list
moduleHead :: OchreParser (ModuleName, [ModuleName])
moduleHead = (,) <$> (whiteSpace *> moduleDecl) 
                 <*> importList

-- | Instrument and Trait defs
moduleTail :: OchreParser ([Instr], [Trait])
moduleTail = collectModule <$> (many topDecl <* eof)


collectModule ::[TopDecl] -> ([Instr], [Trait])
collectModule = foldr fn ([],[])
  where
    fn (I x) (xs,ys) = (x:xs,ys)
    fn (T y) (xs,ys) = (xs,y:ys)


moduleDecl :: OchreParser ModuleName
moduleDecl = reserved "module" *> moduleName <* reserved "where"


importList :: OchreParser [ModuleName]
importList = many importSpec

importSpec :: OchreParser ModuleName
importSpec = reserved "import" *> moduleName

moduleName :: OchreParser ModuleName
moduleName = pModuleIdent >>= next
  where
    pModuleIdent = sepBy1 identifier (char '.')
    next parts   = case makeModuleNameL parts of 
                     Nothing -> parserFail "moduleName (impossible?)"
                     Just ans -> return ans
              


data TopDecl = I Instr | T Trait
  deriving (Eq,Show)

topDecl :: OchreParser TopDecl
topDecl = choice [ I <$> instr
                 , T <$> trait
                 ]

--------------------------------------------------------------------------------
-- Orch spec

orchSpec :: OchreParser OS.OrchSpec
orchSpec = OS.OrchSpec <$> (reserved "orch" *> braces (semiSep instrInstance))


instrInstance :: OchreParser OS.InstrInstance
instrInstance = OS.InstrInstance <$> (reserved "instrument" *> int) 
                              <*> (reserved "is"         *> ident)
                              <*> braces (semiSep initDecl)

initDecl :: OchreParser OS.InitDecl
initDecl = OS.InitDecl <$> ident <*> (reservedOp "=" *> initExpr)

initExpr :: OchreParser OS.Expr
initExpr = initExpr10 <?> "initial expression"


--
initExpr10 :: OchreParser OS.Expr
initExpr10 =  try pAppPure     -- backtrack otherwise ident is a common prefix
          <|> initExpr9
  where
    pAppPure = OS.App  <$> ident <*> parens (commaSep initExpr)


initExpr9 :: OchreParser OS.Expr
initExpr9 =  pCond 
         <|> initExpr8
  where
    pCond = OS.Cond <$> (reserved "cond" *> initExpr) 
                    <*> (reservedOp "?"  *> initExpr)
                    <*> (reservedOp ":"  *> initExpr)


-- | No (^) power-of operator - use is dicouraged in Csound.
--
initExpr8 :: OchreParser OS.Expr
initExpr8 = initExpr7

-- | (*) and (/) left assoc
--
initExpr7 :: OchreParser OS.Expr
initExpr7 =  OS.UnaryE <$> uNeg <*> initExpr
         <|> chainl1 initExpr6 (OS.BinE <$> pOps)
  where
    uNeg  =  NEG <$ reservedOp "-"
    pOps  = (MUL <$ reservedOp "*") <|> (DIV <$ reservedOp "/")

    -- also unary negate

-- | (+) and (-) left assoc
--
initExpr6 :: OchreParser OS.Expr
initExpr6 = chainl1 initExpr5 (OS.BinE <$> p)
  where
    p = (ADD <$ reservedOp "+") <|> (SUB <$ reservedOp "-")


-- | No list operators (no lists)
--
initExpr5 :: OchreParser OS.Expr
initExpr5 = initExpr4


initExpr4 :: OchreParser OS.Expr
initExpr4 = chainl1 initExpr3 (OS.RelE <$> p)
  where
    p = choice [ EQU            <$ reservedOp "=="
               , NEQU           <$ reservedOp "/="
               , LESSTHAN       <$ reservedOp "<"
               , GREATTHAN      <$ reservedOp ">"
               , LTEQU          <$ reservedOp "<="
               , GTEQU          <$ reservedOp ">="
               ]


initExpr3 :: OchreParser OS.Expr
initExpr3 = chainr1 initExpr2 (OS.BinE <$> pLogAdd)
  where
    pLogAdd = LOG_AND <$ reservedOp "&&"

initExpr2 :: OchreParser OS.Expr
initExpr2 = chainr1 initExpr1 (OS.BinE <$> pLogOr)
  where
    pLogOr  = LOG_OR <$ reservedOp "||"

initExpr1 :: OchreParser OS.Expr
initExpr1 = initPrimitive

initPrimitive :: OchreParser OS.Expr 
initPrimitive = initPfield <|> initLiteral <|> initParens <|> initVariable

initPfield :: OchreParser OS.Expr
initPfield = OS.Pfield <$> pfield


initParens :: OchreParser OS.Expr
initParens = parens initExpr

initVariable :: OchreParser OS.Expr
initVariable = OS.Var <$> ident

initLiteral :: OchreParser OS.Expr
initLiteral = OS.Lit <$> choice [ floatLit, intLit, stringLit, boolLit ]
           <?> "literal"  
  where 
    intLit      = OS.Int    <$> int
    floatLit    = OS.Float  <$> decimal
    stringLit   = OS.String <$> stringl
    boolLit     = OS.Bool   <$> bool




--------------------------------------------------------------------------------
-- Instrument or trait


instr :: OchreParser Instr
instr = (\vid super (ts,xs) -> Instr vid super ts xs) 
    <$> (reserved "instr" *> ident) 
    <*> (reserved "extends" *> superclassIdent) 
    <*> braces (prefixSepBy usesDecl methodDecl semi)


superclassIdent :: Parser Ident
superclassIdent =  Ident "#None" <$ reserved "#None"
               <|> ident

trait :: OchreParser Trait
trait = Trait  <$> (reserved "trait" *> ident) <*> traitDefn

traitDefn :: OchreParser TraitDefn
traitDefn = 
    (\(ts,xs) -> TraitDefn ts xs) 
      <$> braces (prefixSepBy usesDecl methodDecl semi)

usesDecl :: OchreParser (Maybe TraitExpr)
usesDecl = reserved "uses" *> braces (optionMaybe traitExpr)


methodDecl :: OchreParser MethodDecl
methodDecl = MethodDecl <$> ident <*> (reservedOp "=" *> methodDefn)

methodDefn :: OchreParser MethodDefn
methodDefn = MethodDefn <$> arglist <*> doBlock

arglist :: OchreParser [Ident]
arglist = pargs <|> return []
  where
    pargs = (reservedOp "\\" *> many1 ident) <* reservedOp "->"

declaration :: OchreParser Decl
declaration = Decl <$> ident <*> (reservedOp "=" *> expression)


--------------------------------------------------------------------------------
-- Trait expressions

traitExpr           :: OchreParser TraitExpr
traitExpr           = exprComp

-- | Composition operator changed to &...
exprComp            :: OchreParser TraitExpr
exprComp            = chainl1 exprExclude (TraitComp <$ reservedOp "&")



exprExclude         :: OchreParser TraitExpr
exprExclude         = exprAlias <??> pExcl
  where
    pExcl = (\b a -> TraitExclude a b) 
              <$> (reserved "minus" *> braces (commaSep ident))

exprAlias           :: OchreParser TraitExpr
exprAlias           = exprPrimitive <??> pAlias
  where
    pAlias = (\xs a -> TraitRename a xs) 
               <$> (reserved "with" *> braces (semiSep traitAlias))

exprPrimitive       :: OchreParser TraitExpr 
exprPrimitive       = exprNamed <|> exprParens

exprNamed           :: OchreParser TraitExpr
exprNamed           = NamedTrait <$> ident

exprParens          :: OchreParser TraitExpr
exprParens          = parens traitExpr


traitAlias :: OchreParser TraitAlias
traitAlias = TraitAlias <$> ident <*> (symbol "->" *> ident)

--------------------------------------------------------------------------------
-- Do expressions

doBlock :: OchreParser DoBlock
doBlock = doMulti <|> doSingle
  where
    doMulti  = reserved "do" *> braces (sepBy doStmt (symbol ";"))
    doSingle = (\a -> [a]) <$> doStmt


doStmt :: OchreParser Stmt
doStmt = pReturn <|> pDoLet <|> pDoLam <|> pDoIf <|> doAction
  where
    pReturn   = Return  <$> (reserved "return" *> expression)
    pDoLet    = DoLet   <$> (reserved "let"    *> declaration)
    pDoLam    = DoLam   <$> (reserved "letfun" *> ident)
                        <*> many1 ident
                        <*> (reservedOp "=" *> doBlock)
    pDoIf     = DoIf    <$> (reserved "if" *> expression)
                        <*> (reserved "then" *> doBlock)
                        <*> (reserved "else" *> doBlock)

-- | var id is common prefix
-- 
doAction :: OchreParser Stmt
doAction = varBind >>= step
  where
    step (Bind1 vid)    =  DoBind (Bind1 vid) <$> (reservedOp "<-" *> doBlock)
                       <|> PrimCall vid <$> commaSep expression

    step tup            = DoBind tup <$> (reservedOp "<-" *> doBlock)


varBind :: OchreParser VarBind
varBind = varTup <|> var1
  where
    varTup = BindTuple <$> parens (commaSep ident)
    var1   = Bind1     <$> ident 

-- Q. Uh-oh how to identify Csound opcodes (i.e. FFI calls)?
-- A. Look them up after parsing.


-- Possibly we can live with this one (not sure if general 
-- application will be supported):
--
expression :: OchreParser Expr
expression = expression10 <?> "expression"


--
expression10 :: OchreParser Expr
expression10 =  try pAppPure     -- backtrack otherwise ident is a common prefix
            <|> expression9
  where
    pAppPure = App  <$> ident <*> parens (commaSep expression)


expression9 :: OchreParser Expr
expression9 =  pCond 
           <|> expression8
  where
    pCond = Cond <$> (reserved "cond" *> expression) 
                 <*> (reservedOp "?"  *> expression)
                 <*> (reservedOp ":"  *> expression)


-- | No (^) power-of operator - use is dicouraged in Csound.
--
expression8 :: OchreParser Expr
expression8 = expression7

-- | (*) and (/) left assoc
--
expression7 :: OchreParser Expr
expression7 =  UnaryE <$> uNeg <*> expression
           <|> chainl1 expression6 (BinE <$> pOps)
  where
    uNeg  =  NEG <$ reservedOp "-"
    pOps  = (MUL <$ reservedOp "*") <|> (DIV <$ reservedOp "/")

    -- also unary negate

-- | (+) and (-) left assoc
--
expression6 :: OchreParser Expr
expression6 = chainl1 expression5 (BinE <$> p)
  where
    p = (ADD <$ reservedOp "+") <|> (SUB <$ reservedOp "-")


-- | No list operators (no lists)
--
expression5 :: OchreParser Expr
expression5 = expression4


expression4 :: OchreParser Expr
expression4 = chainl1 expression3 (RelE <$> p)
  where
    p = choice [ EQU            <$ reservedOp "=="
               , NEQU           <$ reservedOp "/="
               , LESSTHAN       <$ reservedOp "<"
               , GREATTHAN      <$ reservedOp ">"
               , LTEQU          <$ reservedOp "<="
               , GTEQU          <$ reservedOp ">="
               ]

expression3 :: OchreParser Expr
expression3 = chainr1 expression2 (BinE <$> pLogAdd)
  where
    pLogAdd = LOG_AND <$ reservedOp "&&"

expression2 :: OchreParser Expr
expression2 = chainr1 expression1 (BinE <$> pLogOr)
  where
    pLogOr  = LOG_OR <$ reservedOp "||"

expression1 :: OchreParser Expr
expression1 = primitiveExpression


primitiveExpression :: OchreParser Expr 
primitiveExpression = literalExpr <|> parensExpr <|> variableExpr




parensExpr :: OchreParser Expr
parensExpr = disamb <$> parens (commaSep expression)
  where
    -- Do we need nil () ?
    disamb [e] = e
    disamb es  = Tuple es




variableExpr :: OchreParser Expr
variableExpr = Var <$> ident

literalExpr :: OchreParser Expr
literalExpr = Lit <$> choice [ floatLit, intLit, stringLit, boolLit ]
           <?> "literal"  
  where 
    intLit      = Int    <$> int
    floatLit    = Float  <$> decimal
    stringLit   = String <$> stringl
    boolLit     = Bool   <$> bool


--------------------------------------------------------------------------------
-- Identifiers


ident                   :: OchreParser Ident
ident                   = Ident <$> identifier

   

--------------------------------------------------------------------------------
-- Tokens
--------------------------------------------------------------------------------



ochre_lex           :: OchreLexer
ochre_lex           = P.makeTokenParser ochre_def

parens              :: OchreParser a -> OchreParser a
parens              = P.parens ochre_lex 


braces              :: OchreParser a -> OchreParser a
braces              = P.braces ochre_lex

brackets            :: OchreParser a -> OchreParser a
brackets            = P.brackets ochre_lex

-- | skips trailing space
semi                :: OchreParser String
semi                = P.semi ochre_lex

semiSep             :: OchreParser a -> OchreParser [a]
semiSep             = P.semiSep ochre_lex


-- semiSep1            :: OchreParser a -> OchreParser [a]
-- semiSep1            = P.semiSep1 ochre_lex

commaSep            :: OchreParser a -> OchreParser [a]
commaSep            = P.commaSep ochre_lex

commaSep1           :: OchreParser a -> OchreParser [a]
commaSep1           = P.commaSep1 ochre_lex


identifier          :: OchreParser String
identifier          = P.identifier ochre_lex

stringLiteral       :: OchreParser String
stringLiteral       = P.stringLiteral ochre_lex

symbol              :: String ->  OchreParser String
symbol              = P.symbol ochre_lex

reserved            :: String ->  OchreParser ()
reserved s          = P.reserved ochre_lex s
                   <?> "reserved: " ++ s

reservedOp          :: String -> OchreParser ()
reservedOp          = P.reservedOp ochre_lex

int                 :: OchreParser Int
int                 = fromIntegral <$> P.integer ochre_lex

decimal             :: OchreParser Decimal
decimal             = realToFrac <$> try (P.float ochre_lex)

stringl             :: OchreParser String
stringl             = P.stringLiteral ochre_lex

bool                :: OchreParser Bool
bool                = true <|> false
  where
    true  = True  <$ symbol "True"
    false = False <$ symbol "False"

pfield              :: OchreParser Int
pfield              = fromIntegral <$> try (string "p" *> P.integer ochre_lex)

whiteSpace          :: OchreParser ()
whiteSpace          = P.whiteSpace ochre_lex

--------------------------------------------------------------------------------
-- Lang def
--------------------------------------------------------------------------------


-- | Note - allow super prefix @super:@ in identifiers.
--
-- All other occurances of @:@ are an error but go unchecked.
--
ochre_def :: LanguageDef st
ochre_def = haskellStyle
    { P.identStart        = letter
    , P.identLetter       = alphaNum <|> oneOf "_:"
    , P.reservedOpNames   = [ "&", "<-", "=", "*"
                            , "/", "+", "-", "?"
                            , ":", "\\", "->", "$" 
                            ]  
    , P.reservedNames     = [ "module", "where"
                            , "import"
                            , "orch", "instr", "trait"
                            , "instrument", "is"
                            , "extends", "#None", "uses", "do", "let", "letfun"
                            , "cond", "return"
                            , "if", "then", "else"
                            --
                            -- Builtins
                            , "builtins"
                            --
                            -- types
                            , "Any", "String", "Int", "Float"
                            , "ASig", "KSig", "ISig"
                            , "Cs" 
                            ] 
    }

